home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
smaltalk
/
manchest.lha
/
MANCHESTER
/
usenet
/
st80_pre4
/
montana.st
< prev
next >
Wrap
Text File
|
1993-07-24
|
43KB
|
1,588 lines
" NAME montana
AUTHOR Dr Kevin Waite <kww@cs.glasgow.ac.uk>
FUNCTION The game of Montana
ST-VERSIONS 2.5
PREREQUISITES
CONFLICTS
DISTRIBUTION world
VERSION 1.1
DATE 29 Nov 90
SUMMARY A card game called Montana.
"!
"
From: kww@cs.glasgow.ac.uk (Dr Kevin Waite)
Newsgroups: comp.lang.smalltalk
Subject: Montana Game
Message-ID: <7072@vanuata.cs.glasgow.ac.uk>
Date: 29 Nov 90 09:58:37 GMT
Organization: Computing Sci, Glasgow Univ, Scotland
My original posting of an implementation of the Montana game
seems to have got lost. Since I think it is a reasonable example
of simple MVC use (and a reasonable game to boot) I think some
people might find it useful. If it doesn't get out this time
then too bad. I hope you enjoy it.
PS This version includes some heuristics for automatic playing
of the game. The best one finishes about 1 in 10 games.
Address: Dept. of Computing Science, University of Glasgow,
17 Lilybank Gardens, Glasgow, United Kingdom. G12 8QQ
"
Object subclass: #PlayingCard
instanceVariableNames: 'value '
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
PlayingCard comment:
'I am an abstract superclass for playing cards. My subclasses
implement the four suits (Hearts, Spades, Clubs and Diamonds).
Their instances have a value fixed at creation time. They can
be displayed graphically.'!
!PlayingCard methodsFor: 'accessing'!
value
^value!
value: anInteger
value := anInteger.! !
!PlayingCard methodsFor: 'converting'!
ancestor
"Return my ancestor card. This is defined to be the card
of the same suit but with a face value one lower than the
receiver."
| newValue ancestor |
self value = 1 ifTrue: [self error: 'Aces do not have ancestors.'].
newValue := self value - 1.
ancestor := self class value: newValue.
^ancestor!
descendent
"Return my descendent card. This is defined to be the card
of the same suit but with a face value one higher than the
receiver."
| newValue ancestor |
self value = 13 ifTrue: [^nil "Kings do not have descendents"].
newValue := self value + 1.
ancestor := self class value: newValue.
^ancestor! !
!PlayingCard methodsFor: 'displaying'!
displayAt: origin
self displayOn: Display at: origin!
displayOn: aForm at: origin
self
displayOn: aForm
at: origin
clippingBox: (0 @ 0 extent: Display extent)!
displayOn: aForm at: origin clippingBox: box
| image number aRect x y |
image := self class image.
number := self formattedNumber asDisplayText.
aRect := origin extent: self class extent.
aForm white: aRect.
aForm border: aRect width: 2.
x := 3 + ((16 - number width) // 2).
y := 2 + (aRect height - number height) // 2.
number displayOn: aForm at: (x@y) + origin clippingBox: box.
x := aRect width - image width - 4.
y := 1 + (aRect height - image height) // 2.
image displayOn: aForm at: (x@y) + origin clippingBox: box.! !
!PlayingCard methodsFor: 'printing'!
formattedNumber
self value = 1 ifTrue: [^'A'].
self value <= 10 ifTrue: [^self value printString].
self value = 11 ifTrue: [^'J'].
self value = 12 ifTrue: [^'Q'].
self value = 13 ifTrue: [^'K'].
^'Unknown'!
printOn: aStream
aStream nextPutAll: self formattedNumber.
aStream nextPutAll: ' of '.
self printSuitOn: aStream.!
printSuitOn: aStream
aStream nextPutAll: 'Unknown'.! !
!PlayingCard methodsFor: 'testing'!
= otherCard
"Are the receiver and otherCard the same?"
self class == otherCard class ifFalse: [^false].
^self value = otherCard value!
isAce
"Is the receiver an ace?"
^self value = 1!
isKing
"Is the receiver a King?"
^self value = 13! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
PlayingCard class
instanceVariableNames: ''!
!PlayingCard class methodsFor: 'constants'!
extent
"Return the maximum extent of a card's image."
^44@28! !
!PlayingCard class methodsFor: 'instance creation'!
ace
"Return the ace of the receiver class."
^self value: 1!
new
self error: 'Must use the value: instance creation method.'.!
value: aNumber
^super new value: ((aNumber max: 1) min: 13)! !
PlayingCard subclass: #Heart
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
Heart comment:
'My instances are those playing cards whose suit is Hearts.'!
!Heart methodsFor: 'printing'!
printSuitOn: aStream
aStream nextPutAll: 'Hearts'.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
Heart class
instanceVariableNames: ''!
!Heart class methodsFor: 'constants'!
image
^Form
extent: 20 @ 18
fromArray: #(514 0 1285 0 2698 32768 5461 16384 10922 40960 21845 20480 43690 40960 21845 20480 43690 40960 21845 16384 10922 32768 5461 0 2730 0 1364 0 680 0 336 0 160 0 64 0 )
offset: 0 @ 0! !
PlayingCard subclass: #Spade
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
Spade comment:
'My instances are those playing cards whose suit is Spades.'!
!Spade methodsFor: 'printing'!
printSuitOn: aStream
aStream nextPutAll: 'Spades'.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
Spade class
instanceVariableNames: ''!
!Spade class methodsFor: 'constants'!
image
^Form
extent: 14 @ 20
fromArray: #(768 1920 4032 8160 16368 32760 65532 65532 65532 65532 65532 65532 31992 15600 1920 768 4032 4032 768 768 )
offset: 0 @ 0! !
PlayingCard subclass: #Diamond
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
Diamond comment:
'My instances are those playing cards whose suit is Diamonds.'!
!Diamond methodsFor: 'printing'!
printSuitOn: aStream
aStream nextPutAll: 'Diamonds'.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
Diamond class
instanceVariableNames: ''!
!Diamond class methodsFor: 'constants'!
image
^Form
extent: 18@18
fromArray: #( 128 0 320 0 672 0 1360 0 2728 0 5460 0 10922 0 21845 0 43690 32768 21845 16384 10922 32768 5461 0 2730 0 1364 0 680 0 336 0 160 0 64 0)
offset: 0@0! !
PlayingCard subclass: #Club
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
Club comment:
'My instances are those playing cards whose suit is Clubs.'!
!Club methodsFor: 'printing'!
printSuitOn: aStream
aStream nextPutAll: 'Clubs'.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
Club class
instanceVariableNames: ''!
!Club class methodsFor: 'constants'!
image
^Form
extent: 14 @ 18
fromArray: #(768 1920 4032 4032 4032 1920 13104 31608 65532 65532 65532 65532 31992 14448 768 768 4032 4032 )
offset: 0 @ 0! !
FormView subclass: #MontanaView
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Montana'!
MontanaView comment:
'My instances provide a graphical representation of the state of the
board in a game of Montana. My model is the instance of Montana.
My instances listen for two update messages broadcast by my model.
The first, #game, causes the entire board image to be refreshed. This
is typically sent when a board is being reshuffled and at the start of a
game. The second message, #move, takes an argument describing the
last move made by the player. This is used to animate the movement
of the card over the board.'!
!MontanaView methodsFor: 'controller access'!
defaultControllerClass
^MontanaController! !
!MontanaView methodsFor: 'displaying'!
animateCardFrom: start to: finish
"A card has been moved from start position to finish position.
Show this move by animating the movement of the displayed
card between these two positions. This is done by having the
card follow a linear trajectory between these two points with
ten equal steps."
| startBox finishBox steps delta locus pause trajectory image count |
startBox := self boundingBoxForPosition: start.
finishBox := self boundingBoxForPosition: finish.
steps := 10.
delta := (finishBox origin - startBox origin) // steps.
locus := startBox origin.
pause := Delay forMilliseconds: 50.
trajectory := [pause wait. locus := locus + delta].
image := Form fromDisplay: startBox.
count := steps.
Display gray: startBox.
Cursor execute showWhile:
[image follow: trajectory
while: [count := count - 1. count > 0]].
image displayAt: finishBox origin.!
boundingBoxForPosition: position
"Return the rectangle (expressed in Display coordinates)
giving the bounding box of the Montana board at the given
position."
| count cardSize offset x y aRect displacement |
cardSize := PlayingCard extent.
offset := 5.
count := position y.
x := (count * offset) + ((count-1) * cardSize x).
count := position x.
y := (count * offset) + ((count-1) * cardSize y).
displacement := self insetDisplayBox origin.
aRect := (x@y extent: cardSize) translateBy: displacement.
^aRect!
displayView
"Completely regenerate the display of my model's board state."
| origin cardSize y offset clipBox |
Display fill: self insetDisplayBox mask: Form gray.
origin := self insetDisplayBox origin.
cardSize := PlayingCard extent.
offset := 5.
y := origin y + offset.
clipBox := self insetDisplayBox.
self model board do: [:row | | x |
x := origin x + offset.
row do: [:card |
card isNil ifFalse: [
card displayOn: Display at: x@y clippingBox: clipBox].
x := x + cardSize x + offset.
].
y := y + cardSize y + offset.
].!
highlightPosition: position
"Highlight the board at the given position by turning
the image at that location using reverse video."
| aRect |
aRect := self boundingBoxForPosition: position.
Display reverse: aRect.!
showAncestorOfCardAt: position
"This method highlights the ancestor to the card
at the given position. (See the comment of class
PlayingCard for a definition of ancestor). If there
is no such ancestor then flash the display."
| thisCard ancestor locus |
thisCard := self model cardAt: position.
(thisCard isNil or: [thisCard value = 2])
ifTrue: [^self flash].
ancestor := thisCard ancestor.
ancestor isNil ifTrue: [^self flash].
locus := self model positionOfCard: ancestor.
self highlightPosition: locus.
Sensor waitNoButton.
self highlightPosition: locus.!
showDescendentOfCardAt: position
"This method highlights the descendent to the card
at the given position. (See the comment of class
PlayingCard for a definition of descendent). If there
is no such descendent then flash the display."
| thisCard desc locus |
thisCard := self model cardToLeftOf: position.
thisCard isNil ifTrue: [^self flash].
desc := thisCard descendent.
desc isNil ifTrue: [^self flash].
locus := self model positionOfCard: desc.
self highlightPosition: locus.
Sensor waitNoButton.
self highlightPosition: locus.!
update: aspect with: aMove
"A change has occurred in the state of my model.
Depending upon the aspect, update the display accordingly."
(aspect == #move and: [aMove notNil])
ifTrue: [self animateCardFrom: aMove first
to: aMove last].
aspect == #game ifTrue: [self display].! !
!MontanaView methodsFor: 'window access'!
defaultWindow
"Return the window for a graphical display of a Montana board."
| cardSize offset width height |
cardSize := PlayingCard extent.
offset := 5.
width := self model class cardsPerSuit * (cardSize x + offset) + offset.
height := self model class numberOfSuits * (cardSize y + offset) + offset.
^(Rectangle origin: 0 @ 0 extent: width@height) expandBy: self borderWidth! !
Model subclass: #Montana
instanceVariableNames: 'board shufflesLeft lastMove moveCounter '
classVariableNames: 'RND '
poolDictionaries: ''
category: 'Montana'!
Montana comment:
'My instances hold the state of play in the Montana game. For details
on how to play the game execute the following expression:
(Montana instructions).
This version is based on the Macintosh version implemented by Eric Snider.
It has been elaborated slightly so as to illustrate some aspects of the
Smalltalk Model-View-Controller framework. This version started out in
life as a sample solution to an under-graduate Smalltalk introductory
exercise. The game could usefully be extended by a facility for the
program to play the game to completion.
Instance variables:
''rows'' a 4-by-13 array of Cards or nil. Holds the state of the board.
Board positions are accessed using a Point where the x value
is the row number; the y value is the column number.
''shufflesLeft'' an integer saying how many shuffles the player has left.
''lastMove'' a two-element array describing the last move made by the
player. At the start of a game and immediately after a shuffle,
this value is undefined. The first element of the array is the
position of the card before the move; the second element is the
position after the move.
(c) Dr. Kevin Waite, 1990.
Computing Science Department
University of Glasgow
United Kingdom
Email: kww@cs.glasgow.ac.uk'!
!Montana methodsFor: 'accessing'!
cardAt: aPoint
"Return the given card at the specified location on the
Montana board or nil if there is no card."
^(self board at: aPoint x) at: aPoint y!
cardAt: aPoint put: aCard
"Place the given card at the specified location on the
Montana board. A value of nil for aCard means that
this location no longer has a card."
(self board at: aPoint x) at: aPoint y put: aCard.!
lastMove
"Return the last move made by the player as a
two-element array whose first element is the
starting position and the second is the finishing
position for the card."
^lastMove!
lastMove: anArrayOfTwoPoints
"Set the last move made by the player as a
two-element array whose first element is the
starting position and the second is the finishing
position for the card."
lastMove := anArrayOfTwoPoints.!
moveCounter
^moveCounter!
random
"Return the next random number; a value in
the range 0..1."
^RND next!
shufflesLeft
"How many shuffles does the player have left?"
^shufflesLeft!
shufflesLeft: anInteger
shufflesLeft := anInteger.! !
!Montana methodsFor: 'automatic play'!
automaticPlay
"This method is a stub that calls the actual method that does
the playing. This allows alternative methods to be tried quite
easily."
"self randomlyMoveCards."
"self repeatedPriorityMove."
self repeatedRunAndJuggle.!
createAGapAt: position
"Open up a gap at the given position. This may
involve moving an arbitrary number of cards. Return
a boolean saying whether the gap was actually created."
| run |
run := self getRunStartingAt: position.
run isNil ifTrue: [^false].
run do: [:each | self moveCardAtPosition: each].
^true!
getRunStartingAt: position
"A run is defined as an OrderedCollection of card positions
that moved in order will leave a gap at the specified
position. If there is no such run from this position
then return nil. If there is already a gap then the
run will be empty (but non-nil). A constraint on a
run is that a card can only appear once (to avoid
cycles)."
^self
getRunStartingAt: position
building: OrderedCollection new
fixing: Set new!
getRunStartingAt: position building: aRun fixing: fixedPositions
"See the method getRunStartingAt: for details of what
is a run. This method is trying to find a run building onto
the one passed as parameter. Those cards mentioned in
fixedPositions cannot be moved since other cards are depending
on them being in their current position."
| aCard parent holder target |
(aRun includes: position) ifTrue: [^nil "Cycle."].
(fixedPositions includes: position) ifTrue: [^nil "Need this card here"].
(self numberOfPositionedCardsInRow: position x) >= position y ifTrue: [
"Prohibit the movement of a card that is in sequence."
^nil.
].
aCard := self cardAt: position.
aCard isNil ifTrue: [^aRun "We found it."].
parent := aCard ancestor.
parent isAce ifTrue: [
"This run is only possible if there is a vacant
slot in the leftmost column to take aCard (known
here to be a '2' or if we can create a slot."
1 to: self class numberOfSuits do: [:r |
(self isCardAt: r @ 1) ifFalse: [
aRun addFirst: position.
^aRun
].
].
aRun addFirst: position.
1 to: self class numberOfSuits do: [:r |
| trial result |
trial := aRun deepCopy.
result := self
getRunStartingAt: (r@1)
building: trial
fixing: fixedPositions.
result isNil ifFalse: [^result]
].
^nil "No luck in moving this '2'."
].
holder := self positionOfCard: parent.
fixedPositions add: holder.
holder y = self class cardsPerSuit ifTrue: [
"Up against the edge of the board.
Since nothing will fit in behind it we
cannot have a run."
^nil
].
target := holder + (0@1). "Look at slot one to the right."
aRun addFirst: position.
^self getRunStartingAt: target building: aRun fixing: fixedPositions!
placeOrderedCardAt: position
"This method tries to replace the card this position
with the one that should be here given its neighbour.
This first involves opening up a gap here and then
moving in the appropriate card. If we cannot open
a gap then return false otherwise true."
| success locus |
success := self createAGapAt: position.
success ifFalse: [^false].
position y = 1 ifTrue: [ | aTwo |
"In the left most column. Move in an unplace '2'."
aTwo := self findAnUnplacedTwoForRow: position x.
aTwo isNil ifTrue: [^false].
locus := self positionOfCard: aTwo.
] ifFalse: [ | neighbour |
neighbour := self cardToLeftOf: position.
neighbour isNil ifTrue: [^false].
locus := self positionOfCard: neighbour descendent.
].
self moveCardAt: locus to: position.
^true!
priorityBlock
"Return a two-variable block that sorts cards into
decreasing order of preferrance for a move."
^[:aCard :bCard |
(self priorityOfCard: aCard) >
(self priorityOfCard: bCard)]!
priorityMove
| movers priorityMovers start |
movers := self allCardsThatCanMove.
movers isEmpty ifTrue: [^false].
priorityMovers := movers asSortedCollection: self priorityBlock.
start := self positionOfCard: priorityMovers first.
self moveCardAtPosition: start.
^true!
priorityOfCard: aCard
"Return an integer giving the priority that should be
assigned to the moving of this card. The high value
means that this card should always be moved earlier,
a low value means move this later."
| position neighbour dest destNeighbour ordered |
position := self positionOfCard: aCard.
neighbour := self cardToLeftOf: position.
dest := self destinationForCardAt: position.
destNeighbour := self cardToLeftOf: dest.
"Case: Moving a card to its final position."
destNeighbour == aCard ancestor ifTrue: [^20].
"Case: Moving a card that will leave a gap that when
filled will extend a sequence."
ordered := self numberOfPositionedCardsInRow: position x.
position y = (ordered + 1) ifTrue: [^30].
"Case: Moving a card that is to the right of a gap."
neighbour isNil ifTrue: [^10].
"Case: Moving a card that is to the right of a King."
neighbour isKing ifTrue: [^0].
"Otherwise case: Moving a card nearer its final position."
^(aCard value - position y) abs + 5!
randomlyMoveCards
"This method tries to play the game by randomly moving
cards until it cannot move anymore. It then reshuffles and
continues until it runs out of moves and shuffles."
| moves |
[
[moves := self randomlyMoveCardsIntoGaps.
moves > 0] whileTrue.
(self numberOfCardsInOrder < self class placeableCards)
and: [self shufflesLeft > 0]
] whileTrue: [self shuffle].!
randomlyMoveCardsIntoGaps
"This method tries to play the game by randomly moving cards
in the hope that this will eventually converge on the solution."
| gaps moves |
gaps := self positionsOfTheGaps.
moves := 0.
1 to: gaps size do: [:k |
| gap parent position aCard |
gap := gaps at: k.
parent := self cardToLeftOf: gap.
aCard := parent isNil
ifFalse: [parent descendent]
ifTrue: ["Move a '2' into this gap."
gap y = 1
ifTrue: [self findAnUnplacedTwoForRow: gap x]
ifFalse: [nil]].
aCard isNil ifFalse: [
position := self positionOfCard: aCard.
self moveCardAt: position to: gap.
gaps at: k put: position.
moves := moves + 1.
].
].
^moves!
repeatedPriorityMove
[
[self priorityMove] whileTrue.
(self numberOfCardsInOrder < self class placeableCards)
and: [self shufflesLeft > 0]
] whileTrue: [self shuffle].!
repeatedRunAndJuggle
[
[self runAndJuggle] whileTrue.
(self numberOfCardsInOrder < self class placeableCards)
and: [self shufflesLeft > 0]
] whileTrue: [self shuffle].!
runAndJuggle
"This method tries to fill the rows with the proper cards
by moving in the proper cards. It tries this for each row
in turn. If it cannot do a move in any row it performs a
priority-based move in an attempt to free up some space
that can be used as part of a run-based move. This continues
until no more cards can be moved."
| ordered moved |
ordered := Array new: self class numberOfSuits.
1 to: self class numberOfSuits do: [:r |
ordered at: r put: (self numberOfPositionedCardsInRow: r)].
moved := false.
1 to: self class numberOfSuits do: [:r |
| attempt |
attempt := (ordered at: r) + 1.
[attempt < self class cardsPerSuit and: [
self placeOrderedCardAt: r @ attempt]] whileTrue: [
attempt := attempt + 1.
moved := true
].
ordered at: r put: (attempt-1).
].
^moved or: [self priorityMove]! !
!Montana methodsFor: 'initialize-release'!
initialize
"Prepare the receiver for the start of play."
board := Array new: self class numberOfSuits.
1 to: board size do: [:k | | row |
row := Array new: self class cardsPerSuit.
board at: k put: row.
].!
newGame
"Initialize this instance of the game with a random
distribution of cards."
| cards |
cards := OrderedCollection new: self class numberOfCards.
1 to: self class numberOfCards do: [:k | cards add: (self convertToCard: k)].
self shuffleCards: cards ordered: #(0 0 0 0).
self resetShuffleCount.
self resetMoveCounter.
self changed: #game.! !
!Montana methodsFor: 'moving functions'!
allCardsThatCanMove
"Return a collection of the cards that could move
given the current state of the board."
| movers gaps |
movers := Set new.
gaps := self positionsOfTheGaps.
gaps do: [:gap |
| parent aCard |
parent := self cardToLeftOf: gap.
aCard := parent isNil
ifFalse: [parent descendent]
ifTrue: ["Move a '2' into this gap."
gap y = 1
ifTrue: [self findAnUnplacedTwoForRow: gap x]
ifFalse: [nil]].
aCard isNil ifFalse: [movers add: aCard].
].
^movers!
cardToLeftOf: position
"Return the card that appears in the same row as
the given position but one column to the left. If there
is no card at the new location, return nil."
| row col newCol thisCard |
row := position x.
col := position y.
newCol := col - 1.
newCol = 0 ifTrue: [^nil].
thisCard := self cardAt: row @ newCol.
^thisCard!
destinationForCardAt: index
"The card at the given index is about to be moved. Return
the index of the position where it should go to. If there is
already a card there then return nil otherwise return the
position. Note that '2' cards must go the first column: if
there is no free slot then return nil. If the index argument
corresponds to the first column then return the next free
position in that column that is free or nil if none."
| thisCard |
thisCard := self cardAt: index.
thisCard value = 2 ifTrue: [
| r c |
r := index x. c := index y.
c = 1 ifTrue: [ "Move to next free slot in first column."
[r := r = 4 ifTrue: [1] ifFalse: [r+1].
r = index x ifTrue: [^nil].
self isCardAt: r@c] whileTrue.
^r @ c
] ifFalse: [
1 to: 4 do: [:s | (self isCardAt: s@1) ifFalse: [^s @ 1]].
^nil
].
] ifFalse: ["Not a '2': find its ancestor."
| locus destLocus |
locus := self positionOfCard: thisCard ancestor.
"Are we at the end of the row?"
locus y = self class cardsPerSuit ifTrue: [^nil].
destLocus := locus x @ (locus y + 1).
^(self isCardAt: destLocus) ifTrue: [nil] ifFalse: [destLocus]
].
^nil!
moveCardAt: start to: finish
"Move the card currently at location 'start' to its new
location 'finish'. This leaves a gap at start. It is assumed
that initially there is a gap at finish. Once the board has
been updated, announce the change giving details of the
move so that any graphical display of the board can be
updated appropriately."
| thisMove |
self simplyMoveCardAt: start to: finish.
thisMove := Array with: start with: finish.
self lastMove: thisMove.
self oneMoreMove.
self changed: #move with: thisMove.
self changed: #status.!
moveCardAtPosition: position
| destination |
(self isCardAt: position)
ifFalse: [^self error: 'There is no card here.'].
destination := self destinationForCardAt: position.
destination isNil ifTrue: [^self error: 'This is an illegal move.'].
self moveCardAt: position to: destination!
numberOfCardsInOrder
"Return the number of cards that are in the proper order.
This is used to compute the current score in the game."
^(1 to: self class numberOfSuits) inject: 0 into: [:total :r |
total + (self numberOfPositionedCardsInRow: r)]!
numberOfPositionedCardsInRow: r
"How cards are in their correct position in the
given row? A card N is in its proper position if it
is a member of the sequence 2, 3,...,N with the
sequence starting in the leftmost column of the row."
| suit |
suit := nil.
1 to: self class cardsPerSuit do: [:c |
| v thisCard |
v := c + 1.
thisCard := self cardAt: r @ c.
suit isNil
ifTrue: [suit := thisCard class]
ifFalse: [suit == thisCard class
ifFalse: [^c-1]].
(thisCard isNil or: [
thisCard value ~= v]) ifTrue: [^c-1]
].
^self class cardsPerSuit!
positionOfCard: aCard
"Return the position of the given card as an instance
of Point with the x value denoting the row and the y
value denoting the column occupied by aCard."
1 to: self class numberOfSuits do: [:r |
1 to: self class cardsPerSuit do: [:c |
(self cardAt: r @ c) = aCard ifTrue: [^r @ c]]].
self error: 'Could not find the given card.'.!
simplyMoveCardAt: start to: finish
"Move the card currently at location 'start' to its new
location 'finish'. This leaves a gap at start. It is assumed
that initially there is a gap at finish."
| thisCard |
(self isCardAt: finish) ifTrue: [self error].
thisCard := self cardAt: start.
self cardAt: start put: nil.
self cardAt: finish put: thisCard.! !
!Montana methodsFor: 'private'!
board
"Returns the current state of the board."
^board!
board: anArrayOfRows
"Assigns the argument to be the new state of the board."
board := anArrayOfRows!
convertToCard: index
"The argument 'index' is an integer in the
range [1,52]. Convert this number into a
unique card instance."
| suit number cardClass aCard ind |
ind := index - 1.
suit := ind // self class cardsPerSuit.
number := (ind - (suit * self class cardsPerSuit)) + 1.
cardClass := suit = 0 ifTrue: [Club] ifFalse: [
suit = 1 ifTrue: [Heart] ifFalse: [
suit = 2 ifTrue: [Spade] ifFalse: [
suit = 3 ifTrue: [Diamond]]]].
aCard := cardClass value: number.
^aCard!
findAnUnplacedTwoForRow: row
"Return a '2' card that would best fit into the given
row. There are various situations were one '2' is better
than another."
| twos preferred neighbour ordered first |
"Is there already a '2' as the first card in this row but
not in the left-most column? If so then move it so that
it is in that column."
first := self firstCardInRow: row.
first value = 2 ifTrue: [^first].
"See if there is already a sequence 3,4,... in place that
needs a start."
twos := OrderedCollection new.
1 to: self class numberOfSuits do: [:r |
ordered := self numberOfPositionedCardsInRow: r.
"Don't consider solitary '2's as being immovable."
(ordered max: 1) to: self class cardsPerSuit do: [:c |
| aCard |
aCard := self cardAt: r @ c.
(aCard notNil and: [aCard value = 2])
ifTrue: [twos add: aCard]
].
].
neighbour := self cardAt: row @ 2.
preferred := twos detect: [:card | neighbour = card descendent]
ifNone: [nil].
"If there was no preferred two then return one that
is not already in the leftmost column."
^preferred isNil
ifFalse: [preferred]
ifTrue: [twos
detect: [:card | (self positionOfCard: card) y > 2]
ifNone: [twos first]]!
firstCardInRow: r
"Return the left-most card in the given row."
1 to: self class cardsPerSuit do: [:c |
| aCard |
aCard := self cardAt: r @ c.
aCard isNil ifFalse: [^aCard].
].
^nil!
oneLessShuffleLeft
"The player has used up one more shuffle
of the unordered cards."
shufflesLeft := shufflesLeft - 1.
self changed: #status.!
oneMoreMove
moveCounter := moveCounter + 1.!
positionsOfTheGaps
"Return an array giving the positions of the
gaps in the board."
| gaps |
gaps := OrderedCollection new.
1 to: self class numberOfSuits do: [:r |
1 to: self class cardsPerSuit do: [:c |
(self isCardAt: r @ c) ifFalse: [gaps add: r @ c]
].
].
^gaps!
removeAces
"Remove the aces from the board in order to create the
gaps necessary for moving the other cards."
1 to: self class numberOfSuits do: [:r |
1 to: self class cardsPerSuit do: [:c |
| aCard |
aCard := self cardAt: r @ c.
(aCard notNil and: [aCard isAce])
ifTrue: [self cardAt: r @ c put: nil].
].
].!
resetMoveCounter
moveCounter := 0.!
resetShuffleCount
"Reset the number of available shuffles to the starting value."
shufflesLeft := 2.
self changed: #status.!
shuffleCards: cards ordered: orderedColumns
"This method randomly fills the non-ordered columns
of the board with cards picked from 'cards'. This set
is destroyed by this method. The orderedColumns
argument states how many columns are ordered for
each row."
1 to: self class numberOfSuits do: [:r |
| start |
start := (orderedColumns at: r) + 1.
start to: self class cardsPerSuit do: [:c |
| index thisCard |
"Get an integral random number in the range [1, cards size]."
index := (self random * (cards size-1)) rounded + 1.
thisCard := cards removeAtIndex: index.
self cardAt: r @ c put: thisCard.
].
].
self removeAces.!
undefinedLastMove
"Prevent the player from performing an undo last move
command. This is necessary at the start of a game and
immediately after a shuffle command."
self lastMove: nil.! !
!Montana methodsFor: 'statistics'!
collectStatistics: count
| results log tock tick ticker moves max |
results := Array new: self class numberOfCards.
moves := Dictionary new.
results atAllPut: 0.
tock := (count // 100) rounded.
tick := tock.
ticker := 0.
count timesRepeat: [
| placed remaining used |
self automaticPlay.
placed := self numberOfCardsInOrder.
remaining := self class placeableCards - placed + 1.
results at: remaining put: (results at: remaining) + 1.
used := moves at: self moveCounter ifAbsent: [0].
moves at: self moveCounter put: used+1.
self newGame.
tick := tick - 1.
tick = 0 ifTrue: [
ticker := ticker + 1.
Transcript show: ticker printString, '% at ', Time now printString; cr.
tick := tock.
].
].
log := 'Remaining.results' asFilename writeStream.
log nextPutAll: 'Remaining'; tab.
log nextPutAll: 'Count'; cr.
1 to: results size do: [:k |
log nextPutAll: (k-1) printString.
log tab.
log nextPutAll: (results at: k) printString.
log cr.
].
log close.
log := 'Moves.results' asFilename writeStream.
log nextPutAll: 'Moves'; tab.
log nextPutAll: 'Count'; cr.
max := moves keys inject: 0 into: [:big :k | big max: k].
1 to: max do: [:k |
log nextPutAll: k printString.
log tab.
log nextPutAll: (moves at: k ifAbsent: [0]) printString.
log cr.
].
log close.! !
!Montana methodsFor: 'testing'!
hasLastMove
"Do we have a valid last move that can be undone?"
^self lastMove notNil!
isCardAt: index
"Is there a card at the given location?"
^(self cardAt: index) notNil! !
!Montana methodsFor: 'view adaptor'!
instructions
| title info |
title := Text string: 'Montana Instructions' emphasis: 5.
info := Text string: '
Montana is a solitaire card game where the player tries to order cards
by suit from 2 to king. A new game starts with all the cards dealt at
random in four rows of thirteen columns. Then all the aces are removed
to leave four gaps.
Cards can only be moved into the gaps. A card can only be moved to
the right of the card of the same suit but with face value one lower.
For example, if there is a gap to the right of the 3 of spades then
the only card that can be moved there is the 4 of spades. Any gap
to the right of a king is dead since no card has higher value and so
nothing can be moved there. If there is a gap in the leftmost column
then any 2 may be moved there. To move a card, simply click on it using
the left mouse button. If that card cannot move then the card it should
go behind is highlighted. Clicking on a gap highlights the card that can be
moved to that gap. An illegal action causes the board to flash.
Once there are no more mores available, you can shuffle all the cards
that are no in the correct order. You are allowed two shuffles per
game. Commands to shuffle the cards, start a new game, and undo the
last move are selected from a pop-up menu on the middle mouse button.
The status window below the board tells you how many cards
are in order and the the number of shuffles remaining.
(c) Kevin Waite, 1990.' emphasis: 1.
^title, info!
scoreText
"Returns a text string that is used in displaying the score."
| comment remaining percentage placed |
placed := self numberOfCardsInOrder.
remaining := self class placeableCards - placed.
comment := 'Cards still to position = ', remaining printString.
percentage := ((placed / self class placeableCards) * 100) rounded.
comment := comment, ' Score = ', percentage printString, '%. '.
comment := comment, ' Number of moves = ', self moveCounter printString, ' '.
^Text string: comment withCRs emphasis: 2!
shuffleText
"Return a text string saying how many shuffles are
left in the game."
| comment |
comment := 'Remaining shuffles = ', self shufflesLeft printString.
^Text string: comment emphasis: 2!
status
"The complete status message for the game is a
concatenation of the score and the remaining shuffles."
^self scoreText, self shuffleText! !
!Montana methodsFor: 'menu functions'!
openInstructions
| topView infoView |
topView := StandardSystemView new model: self.
topView borderWidth: 2.
topView label: 'Montana Instructions'.
infoView := TextView on: self aspect: #instructions change: nil menu: nil.
infoView borderWidth: 1.
topView addSubView: infoView.
topView minimumSize: 500@500.
topView controller open.!
shuffle
"Randomly re-arrange those cards that
are not in correct order."
| ordered cards aces |
self shufflesLeft = 0 ifTrue: [^self "Cannot shuffle any more."].
aces := ReadStream on: self class aces.
cards := OrderedCollection new: self class numberOfCards.
"Find where the ordered part of each row ends and collect
together all those cards that appear in the unordered part."
ordered := Array new: self class numberOfSuits.
1 to: self class numberOfSuits do: [:r |
| count |
count := self numberOfPositionedCardsInRow: r.
ordered at: r put: count.
(count+1) to: self class cardsPerSuit do: [:c |
| thisCard |
thisCard := (self isCardAt: r @ c)
ifTrue: [self cardAt: r @ c]
ifFalse: [aces next].
cards add: thisCard.
].
].
self shuffleCards: cards ordered: ordered.
self changed: #game.
self oneLessShuffleLeft.
self undefinedLastMove.!
undoLastMove
"The last move made by the player is reversed with the
property that two consecutive undo operations leave the
board untouched.
The move information is held as an array of two points.
Note that undoing the last move DOES increment the
move counter."
| start finish |
start := self lastMove first.
finish := self lastMove last.
self moveCardAt: finish to: start.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
Montana class
instanceVariableNames: ''!
!Montana class methodsFor: 'constants'!
aces
^Array
with: Club ace
with: Diamond ace
with: Spade ace
with: Heart ace!
cardsPerSuit
"Return the number of cards in each suit."
^13!
numberOfCards
"Return the total number of cards in the pack."
^52!
numberOfSuits
"Return the number of suits."
^4!
placeableCards
"How many cards does the user have to arrange to
complete the game?"
^self numberOfCards - 4 "Number of aces"!
statusHeight
"What is the height of the status panel of the game?"
^40! !
!Montana class methodsFor: 'initialize-release'!
initialize
"Reset the random number generator."
RND := Random new.! !
!Montana class methodsFor: 'instance creation'!
instructions
"Provide some help information on how to play the game."
self new openInstructions!
new
self initialize.
^super new initialize!
open
"Create a new instance of the game and open a graphical
display of the board and a textual summary of the game status."
"Montana open"
| montana topView montanaView boardSize statusView size |
montana := self new newGame.
topView := StandardSystemView new model: montana.
topView borderWidth: 2.
topView label: 'Montana'.
montanaView := MontanaView new model: montana.
topView addSubView: montanaView.
statusView := TextView on: montana aspect: #status change: nil menu: nil.
topView addSubView: montanaView in: (0@0 extent: 1@0.8) borderWidth: 2.
topView addSubView: statusView in: (0@0.8 extent: 1@0.2) borderWidth: 2.
boardSize := montanaView defaultWindow extent.
size := boardSize + (0 @ self statusHeight).
topView minimumSize: size.
topView maximumSize: size.
topView controller open.! !
Montana initialize!
MouseMenuController subclass: #MontanaController
instanceVariableNames: ''
classVariableNames: 'Game GameAndUndo GameMenu Shuffle ShuffleAndMove ShuffleAndUndo ShuffleMenu '
poolDictionaries: ''
category: 'Montana'!
MontanaController comment:
'My instances control the user interaction in a game of Montana.
The red mouse button is used to control the movement of the cards.
To move a card, simply click on it using the left mouse button. If that
card cannot move then the card it should go behind is highlighted.
Clicking on a gap highlights the card that can be moved to that gap.
An illegal action causes the board to flash.
Commands to shuffle the cards, start a new game, and undo the
last move are selected from a pop-up menu on the middle mouse button.'!
!MontanaController methodsFor: 'control activity'!
isControlActive
^super isControlActive & sensor blueButtonPressed not! !
!MontanaController methodsFor: 'menus'!
gameMenu
^self model hasLastMove
ifTrue: [GameAndUndo]
ifFalse: [Game]!
menu
"Return an ActionMenu offering the commands that
are applicable to this state of the game."
^self model shufflesLeft > 0
ifTrue: [self shuffleMenu]
ifFalse: [self gameMenu]!
shuffleMenu
^self model hasLastMove
ifTrue: [ShuffleAndUndo]
ifFalse: [Shuffle]! !
!MontanaController methodsFor: 'menu functions'!
moveCardAtPosition: position
"Move the card at the specified position. See my class
comment for details of what happens when an attempt
is made to move a card."
| destination doAFullRun |
doAFullRun := Sensor leftShiftDown.
doAFullRun ifTrue: [ |success |
success := self model placeOrderedCardAt: position.
success ifFalse: [self view flash].
^self
].
(self model isCardAt: position)
ifFalse: [^self view showDescendentOfCardAt: position].
destination := self model destinationForCardAt: position.
destination isNil ifTrue: [^self view showAncestorOfCardAt: position].
self model moveCardAtPosition: position.! !
!MontanaController methodsFor: 'mouse activity'!
mousePositionAsBoardLocation
"Convert the current mouse position into a Point that
describes the position of the mouse on the Montana
board. The x position refers to the row number; the
y value gives the column number."
| origin locus cardSize offset increment count row col |
origin := self view insetDisplayBox origin.
locus := sensor mousePoint - origin.
cardSize := PlayingCard extent.
offset := 5.
increment := cardSize y + offset.
count := (locus y \\ increment) - offset.
row := count >= 0
ifTrue: [(locus y // increment) + 1]
ifFalse: [^nil].
increment := cardSize x + offset.
count := (locus x \\ increment) - offset.
col := count >= 0
ifTrue: [(locus x // increment) + 1]
ifFalse: [^nil].
^row @ col!
redButtonActivity
| locus |
locus := self mousePositionAsBoardLocation.
locus isNil ifFalse: [self moveCardAtPosition: locus].!
yellowButtonActivity
| aMenu index selector saved |
sensor leftShiftDown ifTrue: [
self model priorityMove.
sensor waitNoButton.
^self
].
aMenu := self menu.
aMenu isNil ifFalse: [
self controlTerminate.
index := aMenu startUp.
index ~= 0 ifTrue: [
selector := aMenu selectorAt: index.
saved := Cursor currentCursor.
Cursor currentCursor: Cursor execute.
self model perform: selector.
Cursor currentCursor: saved.
].
self controlInitialize.
].! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
MontanaController class
instanceVariableNames: ''!
!MontanaController class methodsFor: 'initialize-release'!
initialize
"MontanaController initialize."
Game := ActionMenu
labels: 'Start New Game\Instructions' withCRs
lines: #(1)
selectors: #(newGame openInstructions).
GameAndUndo := ActionMenu
labels: 'Start New Game\Undo Last Move\Heuristic Play\Instructions' withCRs
lines: #(1)
selectors: #(newGame undoLastMove automaticPlay openInstructions).
Shuffle := ActionMenu
labels: 'Start New Game\Shuffle Unordered Cards\Heuristic Play\Instructions' withCRs
lines: #()
selectors: #(newGame shuffle automaticPlay openInstructions).
ShuffleAndUndo := ActionMenu
labels: 'Start New Game\Shuffle Unordered Cards\Undo Last Move\Heuristic Play\Instructions' withCRs
lines: #()
selectors: #(newGame shuffle undoLastMove automaticPlay openInstructions).! !
MontanaController initialize!
